Power CD/Power CD ATARI-Rechner Lieben.iso/ALLERLEI/GOBJ_112/UNITS/ODIALOGS.PAS

Pascal/Delphi Source File | 1994-03-27 | 28.8 KB | 1,063 lines

{**************************************
 *  O b j e c t G E M   Version 1.12  *
 *  Copyright 1992-94 by Thomas Much  *
 **************************************
 *       Unit  O D I A L O G S        *
 **************************************
 *    Softdesign Computer Software    *
 *    Thomas Much, Gerwigstraße 46,   *
 *  76131 Karlsruhe, (0721) 62 28 41  *
 *         Thomas Much @ KA2          *
 *  [e-mail]  *
 **************************************
 *    erstellt am:        13.07.1992  *
 *    letztes Update am:  27.03.1994  *
 **************************************}

{
  WICHTIGE ANMERKUNGEN ZUM QUELLTEXT:

  ObjectGEM wird ab sofort mit dem _vollständigen_ Quelltext ausgeliefert,
  d.h. jeder kann sich die Unit selbst compilieren, womit die extrem
  lästigen Kompatibilitätsprobleme mit den PP-Releases beseitigt sind.
  ObjectGEM ist und bleibt aber trotzdem SHAREWARE, d.h. wer die Biblio-
  thek regelmäßig benutzt, muß sich REGISTRIEREN lassen (so wie bisher).
  Im Moment gibt es dafür dann "nur" die neueste Version; eine geTEXte
  Doku ist aber in Arbeit, so daß auch ein gedrucktes Handbuch immer
  wahrscheinlicher wird.

  Der Quelltext enthält z.Z. noch _keine_ Kommentare; wer sich dennoch die
  Mühe macht, ihn zu lesen, wird feststellen, daß er außerdem noch recht
  "wirr" und teilweise umständlich geschrieben ist, oder daß er evtl. auch
  unnötige Teile enthält. Das liegt daran, daß dieser Quelltext eigentlich
  gar nicht für eine Veröffentlichung gedacht war, aber immer häufiger auf-
  tretende PP-Updates haben mich schier zur Verzweiflung getrieben...
  Das alles sollte aber kein Grund sein, ObjectGEM nicht einzusetzen, denn
  sobald nach "außen" die von mir gewünschte Funktionalität erreicht ist
  (d.h. wenn alle wichtigen Objekte vorhanden sind, z.B. TEditWindow etc.),
  werde ich mich um die "innere" Optimierung kümmern (dazu gehören dann
  auch die Kommentare). Die bisher geschriebenen ObjectGEM-Anwendungen
  können dann natürlich weiterverwendet werden.

  Wer beim Durchstöbern des Textes auf vermeintliche Fehler oder verbesse-
  rungswürdige Stellen trifft (von letzterem gibt es sicherlich noch viele),
  kann mir dies gerne mitteilen - ich habe auch ich nichts gegen kostenlos
  zur Verfügung gestellte optimierte Routinen (sofern sich jemand die Mühe
  macht). Wer in anderen Projekten, die nicht in direkter Konkurrenz zu
  ObjectGEM stehen, einzelne Routinen verwenden möchte, wendet sich bitte
  an mich (ein solcher Austausch sollte kein Problem sein).

  Wer sich auf nicht dokumentierte "implementation"- oder "private"-Eigen-
  schaften verläßt, darf sich nicht über Inkompatibilitäten zu späteren
  Versionen wundern; wer meint, eine Dokumentationslücke entdeckt zu haben
  (außer dem "Abgrund" des noch fehlenden Handbuchs...), kann mir dies
  gerne mitteilen.

  WICHTIG: Wer den Quelltext verändert und dann Probleme beim Compilieren,
  Ausführen o.ä. hat, kann nicht damit rechnen, daß ich den Fehler suche;
  tritt der Fehler allerdings auch mit dem Original-Quelltext auf, würde
  ich mich über eine genaue Fehlerbeschreibung freuen. Veränderte Quell-
  texte dürfen _nicht_ weitergegeben werden, dies wäre ein Verstoß gegen
  das Copyright!

  Kleine Info zum Schluß: Als "default tabsize" verwende ich 2. Wer drei
  Punkte ("...") im Quelltext entdeckt, hat eine Stelle gefunden, an der
  ich z.Z. arbeite ;-)

  "Möge die OOP mit Euch sein!"
}


{$IFDEF DEBUG}
    {$B+,D+,G-,I-,L+,N-,P-,Q+,R+,S+,T-,V-,X+,Z+}
{$ELSE}
    {$B+,D-,G-,I-,L-,N-,P-,Q-,R-,S-,T-,V-,X+,Z+}
{$ENDIF}

unit ODialogs;

interface

uses

    Gem,OTypes,OWindows;

type

    PScrollBar = ^TScrollBar;
    TScrollBar = object(TControl)
        public
        LineMagnitude,
        PageMagnitude,
        Size         : longint;
        IsHorizontal : boolean;
        constructor Init(AParent: PDialog; SIndx,DIndx,IIndx: integer; TheSize,TheRange: longint; Hlp: string);
        function TestIndex(AnIndx: integer): boolean; virtual;
        function Transfer(DataPtr: pointer; TransferFlag: word): word; virtual;
        procedure Changed(AnIndx: integer; DblClick: boolean); virtual;
        procedure Work; virtual;
        procedure SetPosition(ThumbPos: longint); virtual;
        function GetPosition: longint; virtual;
        function DeltaPos(Delta: longint): longint; virtual;
        procedure SetRange(LoVal,HiVal: longint); virtual;
        function GetRange(var LoVal,HiVal: longint): longint; virtual;
        function GetSBoxMin: integer; virtual;
        private
        lowval,
        highval,
        SPos,
        Range   : longint;
        DecIndx,
        IncIndx : integer;
        initflag: boolean;
        DecAddr,
        IncAddr : PObj
    end;

    PGroupBox = ^TGroupBox;
    TGroupBox = object(TControl)
        public
        constructor Init(AParent: PDialog; AnIndx: integer; ATitle,Hlp: string);
        destructor Done; virtual;
        procedure SetText(ATextString: string); virtual;
        function GetText: string; virtual;
        private
        Title    : PString;
        UsrBlk   : USERBLK;
        oldflags : word;
        oldobspec: longint
    end;

    PCheckBox = ^TCheckBox;
    TCheckBox = object(TButton)
        public
        constructor Init(AParent: PDialog; AnIndx: integer; UserDef: boolean; Hlp: string);
        function Install: boolean; virtual;
        function Transfer(DataPtr: pointer; TransferFlag: word): word; virtual;
        procedure SetCheck(CheckFlag: integer); virtual;
        function GetCheck: integer; virtual;
        procedure Check; virtual;
        procedure Uncheck; virtual;
        procedure Toggle; virtual;
    end;

    PTriState = ^TTriState;
    TTriState = object(TCheckBox)
        public
        constructor Init(AParent: PDialog; AnIndx: integer; Hlp: string);
        procedure Gray; virtual;
    end;

    PRadioButton = ^TRadioButton;
    TRadioButton = object(TCheckBox)
        public
        constructor Init(AParent: PDialog; AnIndx: integer; UserDef: boolean; Hlp: string);
        procedure SetState(StateFlag: integer); virtual;
        function Install: boolean; virtual;
    end;

    PListBox     = ^TListBox;
    TListBox     = object(TControl)
        { ... }
    end;

    PComboBox    = ^TComboBox;
    TComboBox    = object(TControl)
        { ... }
    end;



implementation

uses

    OProcs;

const

    cbUnchecked = $1000;
    cbChecked   = $2000;
    cbGrayed    = $3000;
    cbFlags     = cbUnchecked or cbChecked or cbGrayed;
    cbType      = $4000;
    cbAll       = not(cbFlags or cbType);
    UDCOL       = Blue;
    HOTCOL      = Red;


function DrawGroupBox(dummy1,dummy2: pointer; parm: PARMBLKPtr): word; forward;
function DrawCheckBox(dummy1,dummy2: pointer; parm: PARMBLKPtr): word; forward;
function DrawRadioButton(dummy1,dummy2: pointer; parm: PARMBLKPtr): word; forward;


{ *** Objekt TSCROLLBAR *** }

constructor TScrollBar.Init(AParent: PDialog; SIndx,DIndx,IIndx: integer; TheSize,TheRange: longint; Hlp: string);

    begin
        if not(inherited Init(AParent,SIndx,Hlp)) then fail;
        Style:=cs_ScrollBar;
        ID:=id_NoExit;
        initflag:=true;
        DecIndx:=DIndx;
        IncIndx:=IIndx;
        DecAddr:=@Parent^.DlgTree^[DecIndx];
        IncAddr:=@Parent^.DlgTree^[IncIndx];
        if (DecAddr=nil) or (IncAddr=nil) then
            begin
                inherited Done;
                fail
            end;
        if ((DecAddr^.ob_type and $ff)<>G_BOXCHAR) or ((IncAddr^.ob_type and $ff)<>G_BOXCHAR) or
           ((ObjAddr^.ob_type and $ff)<>G_BOX) or (ObjAddr^.ob_head=-1) then
            begin
                inherited Done;
                fail
            end;
        if ObjAddr^.ob_height>ObjAddr^.ob_width then
            begin
                DecAddr^.ob_spec.index:=(DecAddr^.ob_spec.index and $00ffffff) or ($01000000);
                IncAddr^.ob_spec.index:=(IncAddr^.ob_spec.index and $00ffffff) or ($02000000);
                Parent^.DlgTree^[ObjAddr^.ob_head].ob_width:=ObjAddr^.ob_width;
                Parent^.DlgTree^[ObjAddr^.ob_head].ob_x:=0;
                Style:=Style or sbs_Vert;
                IsHorizontal:=false
            end
        else
            begin
                DecAddr^.ob_spec.index:=(DecAddr^.ob_spec.index and $00ffffff) or ($04000000);
                IncAddr^.ob_spec.index:=(IncAddr^.ob_spec.index and $00ffffff) or ($03000000);
                Parent^.DlgTree^[ObjAddr^.ob_head].ob_height:=ObjAddr^.ob_height;
                Parent^.DlgTree^[ObjAddr^.ob_head].ob_y:=0;
                Style:=Style or sbs_Horz;
                IsHorizontal:=true
            end;
        DecAddr^.ob_flags:=(DecAddr^.ob_flags and not(SELECTABLE or DEFAULT or F_EXIT or EDITABLE or RBUTTON)) or TOUCHEXIT;
        IncAddr^.ob_flags:=(IncAddr^.ob_flags and not(SELECTABLE or DEFAULT or F_EXIT or EDITABLE or RBUTTON)) or TOUCHEXIT;
        ObjAddr^.ob_flags:=(ObjAddr^.ob_flags and not(SELECTABLE or DEFAULT or F_EXIT or EDITABLE or RBUTTON)) or TOUCHEXIT;
        Parent^.DlgTree^[ObjAddr^.ob_head].ob_flags:=(Parent^.DlgTree^[ObjAddr^.ob_head].ob_flags and not(SELECTABLE or DEFAULT or F_EXIT or EDITABLE or RBUTTON)) or TOUCHEXIT;
        Size:=Max(1,TheSize);
        PageMagnitude:=Size;
        LineMagnitude:=1;
        SPos:=-1;
        Range:=Max(1,TheRange-1)+2;
        SetRange(0,Range-2);
        initflag:=false
    end;


function TScrollBar.TestIndex(AnIndx: integer): boolean;

    begin
        TestIndex:=((AnIndx=ObjIndx) or (AnIndx=DecIndx) or (AnIndx=IncIndx) or
                    (AnIndx=ObjAddr^.ob_head))
    end;


function TScrollBar.Transfer(DataPtr: pointer; TransferFlag: word): word;

    begin
        case TransferFlag of
            tf_SetData: with PScrollBarTransferRec(DataPtr)^ do
                                        begin
                                            SetRange(LowValue,HighValue);
                                            SetPosition(Position)
                                        end;
            tf_GetData: with PScrollBarTransferRec(DataPtr)^ do
                                        begin
                                            LowValue:=lowval;
                                            HighValue:=highval;
                                            Position:=GetPosition
                                        end
        end;
        Transfer:=sizeof(TScrollBarTransferRec)
    end;


procedure TScrollBar.Changed(AnIndx: integer; DblClick: boolean);
    var sp,dif           : longint;
        mx,my,ox,oy,px,py: integer;
        less             : boolean;

    begin
        sp:=SPos;
        if AnIndx=DecIndx then
            begin
                if DblClick then sp:=0
                else
                    dec(sp,LineMagnitude)
            end
        else
            if AnIndx=IncIndx then
                begin
                    if DblClick then sp:=Range
                    else
                        inc(sp,LineMagnitude)
                end
            else
                if AnIndx=ObjIndx then
                    begin
                        graf_mkstate(mx,my,ox,ox);
                        objc_offset(Parent^.DlgTree,ObjAddr^.ob_head,ox,oy);
                        if IsHorizontal then less:=(mx<ox)
                        else
                            less:=(my<oy);
                        if less then
                            begin
                                if DblClick then sp:=0
                                else
                                    dec(sp,PageMagnitude)
                            end
                        else
                            begin
                                if DblClick then sp:=Range
                                else
                                    inc(sp,PageMagnitude)
                            end
                    end
                else
                    begin
                        objc_offset(Parent^.DlgTree,ObjAddr^.ob_head,ox,oy);
                        objc_offset(Parent^.DlgTree,ObjIndx,px,py);
                        wind_update(BEG_UPDATE);
                        graf_dragbox(Parent^.DlgTree^[ObjAddr^.ob_head].ob_width,Parent^.DlgTree^[ObjAddr^.ob_head].ob_height,ox,oy,px,py,ObjAddr^.ob_width,ObjAddr^.ob_height,mx,my);
                        if (mx<>ox) or (my<>oy) then
                            begin
                                dif:=Max(0,Range-Size);
                                if IsHorizontal then
                                    begin
                                        ox:=ObjAddr^.ob_width-Parent^.DlgTree^[ObjAddr^.ob_head].ob_width;
                                        if ox<1 then sp:=0
                                        else
                                            sp:=((mx-px)*dif) div ox;
                                    end
                                else
                                    begin
                                        oy:=ObjAddr^.ob_height-Parent^.DlgTree^[ObjAddr^.ob_head].ob_height;
                                        if oy<1 then sp:=0
                                        else
                                            sp:=((my-py)*dif) div oy;
                                    end
                            end;
                        wind_update(END_UPDATE)
                    end;
        SetPosition(sp+lowval)
    end;


procedure TScrollBar.Work;

    begin
    end;


procedure TScrollBar.SetPosition(ThumbPos: longint);
    var dif: longint;

    begin
        dec(ThumbPos,lowval);
        dif:=Range-Size;
        if ThumbPos+Size>Range then ThumbPos:=dif;
        if ThumbPos<0 then ThumbPos:=0;
        if SPos<>ThumbPos then
            begin
                SPos:=ThumbPos;
                if dif<1 then dif:=1;
                if IsHorizontal then
                    Parent^.DlgTree^[ObjAddr^.ob_head].ob_x:=((ObjAddr^.ob_width-Parent^.DlgTree^[ObjAddr^.ob_head].ob_width)*SPos) div dif
                else
                    Parent^.DlgTree^[ObjAddr^.ob_head].ob_y:=((ObjAddr^.ob_height-Parent^.DlgTree^[ObjAddr^.ob_head].ob_height)*SPos) div dif;
                if not(initflag) then
                    begin
                        Paint;
                        Work
                    end
            end
    end;


function TScrollBar.GetPosition: longint;

    begin
        GetPosition:=SPos+lowval
    end;


function TScrollBar.DeltaPos(Delta: longint): longint;

    begin
        if Delta<>0 then SetPosition(SPos+lowval+Delta);
        DeltaPos:=SPos+lowval
    end;


procedure TScrollBar.SetRange(LoVal,HiVal: longint);
    var sp,s,TheRange: longint;

    begin
        TheRange:=HiVal+1-LoVal;
        if TheRange<1 then
            begin
                HiVal:=LoVal+1;
                TheRange:=1
            end;
        lowval:=LoVal;
        highval:=HiVal;
        if Range<>TheRange then
            begin
                Range:=TheRange;
                if IsHorizontal then
                    begin
                        s:=(ObjAddr^.ob_width*Size) div Range;
                        if s>ObjAddr^.ob_width then s:=ObjAddr^.ob_width;
                        if s<GetSBoxMin then s:=GetSBoxMin;
                        Parent^.DlgTree^[ObjAddr^.ob_head].ob_width:=s
                    end
                else
                    begin
                        s:=(ObjAddr^.ob_height*Size) div Range;
                        if s>ObjAddr^.ob_height then s:=ObjAddr^.ob_height;
                        if s<GetSBoxMin then s:=GetSBoxMin;
                        Parent^.DlgTree^[ObjAddr^.ob_head].ob_height:=s
                    end;
                sp:=SPos;
                SetPosition(SPos+lowval);
                if sp=SPos then
                    if not(initflag) then
                        begin
                            Paint;
                            Work
                        end
            end
    end;


function TScrollBar.GetRange(var LoVal,HiVal: longint): longint;

    begin
        LoVal:=lowval;
        HiVal:=highval;
        GetRange:=Range+1
    end;


function TScrollBar.GetSBoxMin: integer;

    begin
        GetSBoxMin:=8
    end;

{ *** TSCROLLBAR *** }



{ *** Objekt TGROUPBOX *** }

constructor TGroupBox.Init(AParent: PDialog; AnIndx: integer; ATitle,Hlp: string);

    begin
        if not(inherited Init(AParent,AnIndx,Hlp)) then fail;
        Style:=cs_GroupBox;
        Title:=NewStr(ATitle);
        if ((ObjAddr^.ob_type and $ff)=G_BOX) and (Title<>nil) then
            with ObjAddr^ do
                begin
                    oldflags:=ob_flags;
                    oldobspec:=ob_spec.index;
                    UsrBlk.ub_parm:=longint(Title);
                    UsrBlk.ub_code:=@DrawGroupBox;
                    ob_flags:=ob_flags and not(RBUTTON or EDITABLE or SELECTABLE or DEFAULT or F_EXIT or TOUCHEXIT);
                    ob_type:=G_USERDEF;
                    ob_spec.user_blk:=@UsrBlk
                end
        else
            begin
                DisposeStr(Title);
                inherited Done;
                fail
            end
    end;


destructor TGroupBox.Done;

    begin
        with ObjAddr^ do
            begin
                ob_spec.index:=oldobspec;
                ob_type:=G_BOX;
                ob_flags:=oldflags
            end;
        DisposeStr(Title);
        inherited Done
    end;


procedure TGroupBox.SetText(ATextString: string);
    var nt: PString;

    begin
        nt:=NewStr(ATextString);
        if nt<>nil then
            begin
                DisposeStr(Title);
                Title:=nt;
                UsrBlk.ub_parm:=longint(Title);
                Paint
            end
    end;


function TGroupBox.GetText: string;

    begin
        if Title<>nil then GetText:=Title^ else GetText:=''
    end;

{ *** TGROUPBOX ***}



{ *** Objekt TCHECKBOX *** }

constructor TCheckBox.Init(AParent: PDialog; AnIndx: integer; UserDef: boolean; Hlp: string);

    begin
        if not(inherited Init(AParent,AnIndx,id_No,UserDef,Hlp)) then fail;
        EnableTransfer;
        Style:=cs_CheckBox;
        if UsrDef then
            with ObjAddr^ do
                begin
                    ob_type:=ob_type and cbAll;
                    if bTst(ob_state,SELECTED) then ob_type:=ob_type or cbChecked
                    else
                        ob_type:=ob_type or cbUnchecked
                end
    end;


function TCheckBox.Install: boolean;

    begin
        with ObjAddr^ do
            if (ob_type and $ff)=G_BUTTON then
                begin
                    UsrBlk.ub_parm:=ob_spec.index;
                    UsrBlk.ub_code:=@DrawCheckBox;
                    ob_flags:=(ob_flags and not(RBUTTON or EDITABLE)) or SELECTABLE;
                    ob_state:=ob_state and not(CHECKED or OUTLINED or SHADOWED);
                    ob_type:=G_USERDEF;
                    ob_spec.user_blk:=@UsrBlk
                end
            else
                UsrDef:=false;
        Install:=true
    end;


function TCheckBox.Transfer(DataPtr: pointer; TransferFlag: word): word;

    begin
        case TransferFlag of
            tf_SetData: SetCheck(PWord(DataPtr)^);
            tf_GetData: PWord(DataPtr)^:=GetCheck
        end;
        Transfer:=2
    end;


procedure TCheckBox.SetCheck(CheckFlag: integer);

    begin
        if CheckFlag=bf_Grayed then
            if not(bTst(Style,cs_3State)) then CheckFlag:=bf_Unchecked;
        if GetCheck<>CheckFlag then
            begin
                with ObjAddr^ do
                    if UsrDef then
                        case CheckFlag of
                            bf_Unchecked: begin
                                                            ob_type:=(ob_type and not(cbFlags)) or cbUnchecked;
                                                            ob_state:=ob_state and not(SELECTED)
                                                        end;
                            bf_Checked:   begin
                                                            ob_type:=(ob_type and not(cbFlags)) or cbChecked;
                                                            ob_state:=ob_state or SELECTED
                                                        end;
                            bf_Grayed:    ob_type:=ob_type or cbGrayed
                        end
                    else
                        case CheckFlag of
                            bf_Unchecked: ob_state:=ob_state and not(SELECTED)
                        else
                            ob_state:=ob_state or SELECTED
                        end;
                Paint
            end
    end;


function TCheckBox.GetCheck: integer;

    begin
        with ObjAddr^ do
            if UsrDef then
                case (ob_type and cbFlags) of
                    cbUnChecked: GetCheck:=bf_Unchecked;
                    cbChecked  : GetCheck:=bf_Checked;
                    cbGrayed   : GetCheck:=bf_Grayed
                else
                    GetCheck:=bf_Unchecked
                end
            else
                begin
                    if bTst(ob_state,SELECTED) then GetCheck:=bf_Checked
                    else
                        GetCheck:=bf_Unchecked
                end
    end;


procedure TCheckBox.Check;

    begin
        SetCheck(bf_Checked)
    end;


procedure TCheckBox.Uncheck;

    begin
        SetCheck(bf_Unchecked)
    end;


procedure TCheckBox.Toggle;

    begin
        case GetCheck of
            bf_Unchecked: SetCheck(bf_Checked);
            bf_Checked:   SetCheck(bf_Grayed);
            bf_Grayed:    SetCheck(bf_Unchecked)
        end
    end;

{ *** TCHECKBOX *** }



{ *** Objekt TTRISTATE *** }

constructor TTriState.Init(AParent: PDialog; AnIndx: integer; Hlp: string);

    begin
        if not(TCheckBox.Init(AParent,AnIndx,true,Hlp)) then fail;
        Style:=cs_3State;
        with ObjAddr^ do ob_type:=ob_type or cbType
    end;


procedure TTriState.Gray;

    begin
        SetCheck(bf_Grayed)
    end;

{ *** TTRISTATE ***}



{ *** Objekt TRADIOBUTTON *** }

constructor TRadioButton.Init(AParent: PDialog; AnIndx: integer; UserDef: boolean; Hlp: string);

    begin
        if not(inherited Init(AParent,AnIndx,UserDef,Hlp)) then fail;
        Style:=cs_RadioButton
    end;


procedure TRadioButton.SetState(StateFlag: integer);

    begin
        if GetState<>StateFlag then
            begin
                if StateFlag=bf_Disabled then Uncheck;
                inherited SetState(StateFlag)
            end
    end;


function TRadioButton.Install: boolean;

    begin
        with ObjAddr^ do
            if (ob_type and $ff)=G_BUTTON then
                begin
                    UsrBlk.ub_parm:=ob_spec.index;
                    UsrBlk.ub_code:=@DrawRadioButton;
                    ob_flags:=(ob_flags and not(EDITABLE)) or RBUTTON or SELECTABLE;
                    ob_state:=ob_state and not(CROSSED or CHECKED or OUTLINED or SHADOWED);
                    ob_type:=G_USERDEF;
                    ob_spec.user_blk:=@UsrBlk
                end
            else
                UsrDef:=false;
        Install:=true
    end;

{ *** TRADIOBUTTON *** }



function DrawGroupBox(dummy1,dummy2: pointer; parm: PARMBLKPtr): word;
    var clip: ARRAY_4;

    begin
        InitVWrk;
        with parm^ do
            begin
                clip[0]:=pb_xc;
                clip[1]:=pb_yc;
                clip[2]:=pb_xc+pb_wc-1;
                clip[3]:=pb_yc+pb_hc-1;
                vs_clip(Application^.vdiHandle,CLIP_ON,clip);
                clip[0]:=pb_x;
                clip[1]:=pb_y;
                clip[2]:=pb_x+pb_w-1;
                clip[3]:=pb_y+pb_h-1
            end;
        with Application^ do
            begin
                vsf_interior(vdiHandle,FIS_SOLID);
                vsf_color(vdiHandle,SysInfo.BGDefCol);
                v_bar(vdiHandle,clip);
                vsf_interior(vdiHandle,FIS_HOLLOW);
                vsf_color(vdiHandle,Black);
                vswr_mode(vdiHandle,MD_TRANS);
                v_bar(vdiHandle,clip);
                if length(PString(parm^.pb_parm)^)>0 then
                    begin
                        gem.vswr_mode(vdiHandle,MD_ERASE);
                        gem.vst_color(vdiHandle,SysInfo.BGDefCol);
                        v_gtext(vdiHandle,parm^.pb_x+Attr.charSWidth,parm^.pb_y+(SysInfo.SFHeight shr 1),' '+PString(parm^.pb_parm)^+' ');
                        gem.vswr_mode(vdiHandle,MD_TRANS);
                        v_gtext(vdiHandle,parm^.pb_x+Attr.charSWidth,parm^.pb_y+(SysInfo.SFHeight shr 1),' '+PString(parm^.pb_parm)^+' ');
                        gem.vst_color(vdiHandle,Black);
                        v_gtext(vdiHandle,parm^.pb_x+Attr.charSWidth,parm^.pb_y+(SysInfo.SFHeight shr 1),' '+PString(parm^.pb_parm)^+' ')
                    end
            end;
        RestoreVWrk;
        DrawGroupBox:=NORMAL
    end;


function DrawCheckBox(dummy1,dummy2: pointer; parm: PARMBLKPtr): word;
    var clip            : ARRAY_4;
        tx,ty,scpos,stat: integer;
        q               : word;
        btn             : string[40];

    begin
        InitVWrk;
        with parm^ do
            begin
                clip[0]:=pb_xc;
                clip[1]:=pb_yc;
                clip[2]:=pb_xc+pb_wc-1;
                clip[3]:=pb_yc+pb_hc-1;
                vs_clip(Application^.vdiHandle,CLIP_ON,clip);
                clip[0]:=pb_x+1;
                clip[1]:=pb_y+1;
                clip[2]:=clip[0]+13;
                clip[3]:=clip[1]+13;
                case (pb_tree^[pb_obj].ob_type and cbFlags) of
                    cbChecked:   stat:=bf_Checked;
                    cbGrayed:    stat:=bf_Grayed
                else
                    stat:=bf_Unchecked
                end;
                if pr_currstate<>pr_prevstate then
                    begin
                        inc(stat);
                        if bTst(pb_tree^[pb_obj].ob_type,cbType) then q:=3 else q:=2;
                        if stat>q then stat:=1;
                        case stat of
                            bf_Checked:   q:=cbChecked;
                            bf_Grayed:    q:=cbGrayed
                        else
                            q:=cbUnchecked
                        end;
                        pb_tree^[pb_obj].ob_type:=(pb_tree^[pb_obj].ob_type and not(cbFlags)) or q
                    end;
                if (stat<>bf_Unchecked) or bTst(pr_currstate,CROSSED) then for q:=0 to 3 do inc(clip[q])
            end;
        with Application^ do
            begin
                if stat=bf_Grayed then
                    begin
                        if Attr.Colors>=LWhite then
                            begin
                                gem.vsf_interior(vdiHandle,FIS_SOLID);
                                gem.vsf_color(vdiHandle,LWhite)
                            end
                        else
                            begin
                                gem.vsf_interior(vdiHandle,FIS_PATTERN);
                                gem.vsf_style(vdiHandle,1)
                            end
                    end;
                v_bar(vdiHandle,clip);
                if stat<>bf_Unchecked then
                    begin
                        pxya[0]:=clip[0]-1;
                        pxya[1]:=clip[3]-1;
                        pxya[2]:=clip[0]-1;
                        pxya[3]:=clip[1]-1;
                        pxya[4]:=clip[2]-1;
                        pxya[5]:=clip[1]-1;
                        gem.vsl_color(vdiHandle,SysInfo.BGDefCol);
                        v_pline(vdiHandle,3,pxya);
                        if stat=bf_Checked then
                            begin
                                gem.vsl_color(vdiHandle,LBlack);
                                if bTst(parm^.pr_currstate,CROSSED) then
                                    begin
                                        pxya[0]:=clip[0]+1;
                                        pxya[1]:=clip[1]+1;
                                        pxya[2]:=clip[2]-1;
                                        pxya[3]:=clip[3]-1;
                                        v_pline(vdiHandle,2,pxya);
                                        pxya[0]:=clip[0]+1;
                                        pxya[1]:=clip[3]-1;
                                        pxya[2]:=clip[2]-1;
                                        pxya[3]:=clip[1]+1;
                                        v_pline(vdiHandle,2,pxya)
                                    end
                                else
                                    begin
                                        pxya[0]:=clip[0]+1;
                                        pxya[1]:=clip[3]-1;
                                        pxya[2]:=clip[0]+1;
                                        pxya[3]:=clip[1]+1;
                                        pxya[4]:=clip[2]-1;
                                        pxya[5]:=clip[1]+1;
                                        v_pline(vdiHandle,3,pxya);
                                        gem.vsf_interior(vdiHandle,FIS_SOLID);
                                        gem.vsf_color(vdiHandle,UDCOL);
                                        gem.vsl_color(vdiHandle,UDCOL);
                                        if bTst(parm^.pr_currstate,DISABLED) then
                                            if Attr.Colors>=LWhite then
                                                begin
                                                    gem.vsf_color(vdiHandle,LWhite);
                                                    gem.vsl_color(vdiHandle,LWhite)
                                                end;
                                        pxya[0]:=clip[0]+5;
                                        pxya[1]:=clip[1]+7;
                                        pxya[2]:=clip[0]+4;
                                        pxya[3]:=clip[1]+8;
                                        pxya[4]:=clip[0]+4;
                                        pxya[5]:=clip[1]+11;
                                        pxya[6]:=clip[0]+5;
                                        pxya[7]:=clip[1]+11;
                                        pxya[8]:=clip[0]+11;
                                        pxya[9]:=clip[1]+5;
                                        pxya[10]:=clip[0]+10;
                                        pxya[11]:=clip[1]+5;
                                        pxya[12]:=clip[0]+5;
                                        pxya[13]:=clip[1]+10;
                                        pxya[14]:=clip[0]+5;
                                        pxya[15]:=clip[1]+7;
                                        v_fillarea(vdiHandle,8,pxya)
                                    end
                            end
                        else
                            if Attr.Colors>=LWhite then
                                begin
                                    pxya[0]:=clip[0];
                                    pxya[1]:=clip[1];
                                    pxya[2]:=clip[2];
                                    pxya[3]:=clip[1];
                                    pxya[4]:=clip[2];
                                    pxya[5]:=clip[3];
                                    pxya[6]:=clip[0];
                                    pxya[7]:=clip[3];
                                    pxya[8]:=clip[0];
                                    pxya[9]:=clip[1];
                                    gem.vsl_color(vdiHandle,Black);
                                    v_pline(vdiHandle,5,pxya)
                                end
                    end
                else
                    if not(bTst(parm^.pr_currstate,CROSSED)) then
                        begin
                            pxya[0]:=clip[0]+1;
                            pxya[1]:=clip[3]+1;
                            pxya[2]:=clip[2]+1;
                            pxya[3]:=clip[3]+1;
                            pxya[4]:=clip[2]+1;
                            pxya[5]:=clip[1]+1;
                            gem.vsl_color(vdiHandle,LBlack);
                            v_pline(vdiHandle,3,pxya)
                        end;
                tx:=parm^.pb_x+14+Attr.charSWidth;
                ty:=parm^.pb_y+SysInfo.SFHeight+1;
                btn:=StrLPas(PChar(parm^.pb_parm),40);
                while btn[length(btn)]=' ' do btn[0]:=chr(ord(btn[0])-1);
                scpos:=pos('&',btn);
                if scpos>0 then
                    begin
                        for q:=scpos to length(btn)-1 do btn[q]:=btn[q+1];
                        btn[0]:=chr(ord(btn[0])-1)
                    end;
                gem.vswr_mode(vdiHandle,MD_ERASE);
                gem.vst_color(vdiHandle,SysInfo.BGDefCol);
                v_gtext(vdiHandle,tx,ty,btn);
                gem.vswr_mode(vdiHandle,MD_TRANS);
                v_gtext(vdiHandle,tx,ty,btn);
                if bTst(parm^.pr_currstate,DISABLED) then gem.vst_effects(vdiHandle,TF_LIGHTENED);
                gem.vst_color(vdiHandle,Black);
                v_gtext(vdiHandle,tx,ty,btn);
                if scpos>0 then
                    begin
                        if bTst(parm^.pr_currstate,DISABLED) then gem.vst_effects(vdiHandle,TF_UNDERLINED or TF_LIGHTENED)
                        else
                            begin
                                gem.vst_effects(vdiHandle,TF_UNDERLINED);
                                gem.vst_color(vdiHandle,HOTCOL)
                            end;
                        v_gtext(vdiHandle,tx+(scpos-1)*Attr.charSWidth,ty,' ')
                    end;
                RestoreVWrk
            end;
        DrawCheckBox:=NORMAL
    end;


function DrawRadioButton(dummy1,dummy2: pointer; parm: PARMBLKPtr): word;
    var clip            : ARRAY_4;
        stat,tx,ty,scpos: integer;
        q               : word;
        btn             : string[40];

    begin
        with parm^ do
            begin
                clip[0]:=pb_xc;
                clip[1]:=pb_yc;
                clip[2]:=pb_xc+pb_wc-1;
                clip[3]:=pb_yc+pb_hc-1;
                if (pb_tree^[pb_obj].ob_type and cbFlags)=cbChecked then stat:=bf_Checked
                else
                    stat:=bf_Unchecked;
                if pr_currstate<>pr_prevstate then
                    begin
                        stat:=stat xor 3;
                        if stat=bf_Checked then q:=cbChecked
                        else
                            q:=cbUnchecked;
                        pb_tree^[pb_obj].ob_type:=(pb_tree^[pb_obj].ob_type and not(cbFlags)) or q
                    end;
                vs_clip(Application^.vdiHandle,CLIP_ON,clip);
                InitVWrk;
                pxya[0]:=pb_x+1;
                pxya[1]:=pb_y+8;
                pxya[2]:=pb_x+8;
                pxya[3]:=pb_y+15;
                pxya[4]:=pb_x+15;
                pxya[5]:=pb_y+8;
                pxya[6]:=pb_x+8;
                pxya[7]:=pb_y+1;
                pxya[8]:=pb_x+1;
                pxya[9]:=pb_y+8
            end;
        if stat=bf_Checked then for q:=0 to 4 do inc(pxya[q shl 1]);
        with Application^ do
            begin
                v_fillarea(vdiHandle,5,pxya);
                gem.vsf_perimeter(vdiHandle,PER_ON);
                if stat=bf_Checked then
                    begin
                        pxya[0]:=parm^.pb_x+8;
                        pxya[1]:=parm^.pb_y+1;
                        pxya[2]:=parm^.pb_x+1;
                        pxya[3]:=parm^.pb_y+8;
                        pxya[4]:=parm^.pb_x+8;
                        pxya[5]:=parm^.pb_y+15;
                        gem.vsl_color(vdiHandle,SysInfo.BGDefCol);
                        v_pline(vdiHandle,3,pxya);
                        pxya[0]:=parm^.pb_x+9;
                        pxya[1]:=parm^.pb_y+2;
                        pxya[2]:=parm^.pb_x+3;
                        pxya[3]:=parm^.pb_y+8;
                        pxya[4]:=parm^.pb_x+9;
                        pxya[5]:=parm^.pb_y+14;
                        gem.vsl_color(vdiHandle,LBlack);
                        v_pline(vdiHandle,3,pxya);
                        gem.vsf_interior(vdiHandle,FIS_SOLID);
                        gem.vsf_color(vdiHandle,UDCOL);
                        if bTst(parm^.pr_currstate,DISABLED) then
                            if Attr.Colors>=LWhite then
                                begin
                                    gem.vsf_color(vdiHandle,LWhite);
                                    gem.vsl_color(vdiHandle,LWhite)
                                end;
                        pxya[0]:=parm^.pb_x+7;
                        pxya[1]:=parm^.pb_y+8;
                        pxya[2]:=parm^.pb_x+9;
                        pxya[3]:=parm^.pb_y+10;
                        pxya[4]:=parm^.pb_x+11;
                        pxya[5]:=parm^.pb_y+8;
                        pxya[6]:=parm^.pb_x+9;
                        pxya[7]:=parm^.pb_y+6;
                        pxya[8]:=parm^.pb_x+7;
                        pxya[9]:=parm^.pb_y+8;
                        v_fillarea(vdiHandle,5,pxya)
                    end
                else
                    begin
                        pxya[0]:=parm^.pb_x+9;
                        pxya[1]:=parm^.pb_y+1;
                        pxya[2]:=parm^.pb_x+16;
                        pxya[3]:=parm^.pb_y+8;
                        pxya[4]:=parm^.pb_x+9;
                        pxya[5]:=parm^.pb_y+15;
                        gem.vsl_color(vdiHandle,LBlack);
                        v_pline(vdiHandle,3,pxya)
                    end;
                tx:=parm^.pb_x+14+Attr.charSWidth;
                ty:=parm^.pb_y+SysInfo.SFHeight+1;
                btn:=StrLPas(PChar(parm^.pb_parm),40);
                while btn[length(btn)]=' ' do btn[0]:=chr(ord(btn[0])-1);
                scpos:=pos('&',btn);
                if scpos>0 then
                    begin
                        for q:=scpos to length(btn)-1 do btn[q]:=btn[q+1];
                        btn[0]:=chr(ord(btn[0])-1)
                    end;
                gem.vswr_mode(vdiHandle,MD_ERASE);
                gem.vst_color(vdiHandle,SysInfo.BGDefCol);
                v_gtext(vdiHandle,tx,ty,btn);
                gem.vswr_mode(vdiHandle,MD_TRANS);
                v_gtext(vdiHandle,tx,ty,btn);
                if bTst(parm^.pr_currstate,DISABLED) then gem.vst_effects(vdiHandle,TF_LIGHTENED);
                gem.vst_color(vdiHandle,Black);
                v_gtext(vdiHandle,tx,ty,btn);
                if scpos>0 then
                    begin
                        if bTst(parm^.pr_currstate,DISABLED) then gem.vst_effects(vdiHandle,TF_UNDERLINED or TF_LIGHTENED)
                        else
                            begin
                                gem.vst_effects(vdiHandle,TF_UNDERLINED);
                                gem.vst_color(vdiHandle,HOTCOL)
                            end;
                        v_gtext(vdiHandle,tx+(scpos-1)*Attr.charSWidth,ty,' ')
                    end;
                RestoreVWrk
            end;
        DrawRadioButton:=NORMAL
    end;

end.